perm filename DPYIT.F4[PUR,LCS] blob
sn#334988 filedate 1979-07-23 generic text, type C, neo UTF8
COMMENT ā VALID 00002 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00002 00002 C**** SUBRS LINES, RDRAW, UNPACK, GRIDS, SHIFT, SHIFTX, REPACK
C00009 ENDMK
Cā;
C**** SUBRS LINES, RDRAW, UNPACK, GRIDS, SHIFT, SHIFTX, REPACK
SUBROUTINE LINES(A,B,L)
COMMON /RZ/RSZ,IPLT,RJB,CENTR
COMMON /FL/C,D,NQ,RZ,IXRX,XGP,RXGP
DATA XGP/1200.0/,RX/1.0/
COMMON/MN/M,N
C SET XGP TO 1245.0 FOR MARGIN IN XEROX COPIES
23 IF(IPLT)GO TO 2
M=A*RSZ
N=B*RSZ
IF(L.EQ.3)GO TO 1
IF(IABS(M).GT.600.OR.IABS(N).GT.600)RETURN
C DON'T DISPLAY LINES TOO FAR OFF SCREEN. THEY CAUSE CONFUSION.
CALL AVECT(M,N)
RETURN
1 CALL AIVECT(M,N)
RETURN
CC DIS=RSZ*1.7
CC RHT=RSZ*1.7
2 IF(IXRX.EQ.0)GO TO 9
CC M=-B*RHT-BX+RXGP
AX=-B*RSZ
BX=RX*A*RSZ+XGP
CC N=RX*A*DIS+XGP+AX
GO TO 8
9 AX=A*RSZ
BX=B*RSZ
CC9 M=A*DIS+AX
CC N=B*RHT+BX
8 X=.5
IF(AX)X=-X
Y=.5
IF(BX)Y=-Y
C A AND B ARE FOR ROUND-OFF
M=AX+X
N=BX+Y
CALL PLOT(M,N,L)
END
SUBROUTINE RDRAW(I,JJ,IJ)
C TO X,Y INTO ONE WORD
DIMENSION IJ(1)
COMMON /RZ/RSZ,IPLT,RJB,CENTR
COMMON/LL/L
COMMON/ZN/SCLEF(400,2),DDD
COMMON/MN/M,N
DO 2 K=I,JJ
CALL UNPACK(K,IA,IB,IJ)
A=IA+RJB
B=IB+CENTR
IF(K.EQ.I)GO TO 3
IF(L.LT.100000000)GO TO 1
3 L=3
1 CALL LINES(A,B,L)
SCLEF(K,1)=M
2 SCLEF(K,2)=N
END
SUBROUTINE UNPACK(K,M,N,I)
COMMON/LL/L
C L IS FOR VIS. OR INVIS. LINES.
DIMENSION I(1)
N=I(K)
L=0
IF(N.LT.100000000)GO TO 2
L=(N/100000000)*100000000
N=N-L
2 M=N/10000
N=N-M*10000
IF(M.GT.1000)M=1000-M
IF(N.GT.1000)N=1000-N
END
SUBROUTINE GRIDS
COMMON/RC/MCLEF(400),IST(4000)
COMMON /RZ/RSZ,IPLT,RJB,CENTR
EQUIVALENCE(GRID,IST(4000))
DIMENSION LWRCS(9),IUPCS(8)
DATA LWRCS/9,110281028,10280045,210045,211028,10281028
1,210280017, 10030017,10031028/
1,IUPCS/8,110281028,10280045,370045,371028,10281028
1, 100041028, 40045/
CALL POG2
IF(GRID)GO TO 1
IF(GRID.EQ.1)GO TO 2
IF(GRID.EQ.3)GO TO 3
C NEXT IS UPPER CASE BOX -- GRID=2
CALL RDRAW(2,IUPCS(1),IUPCS,RJB,CENTR)
GO TO 1
3 CALL RDRAW(2,LWRCS(1),LWRCS,RJB,CENTR)
C LOWER CASE BOX
GO TO 1
2 RB=32
RC=35.*9./RSZ
RD=78.*9./RSZ
RA=2
CC IF(IPLT.LT.-1)GO TO 333
C TO SKIP LINES
DO 30 L=-34,78,4
RZ=L
RE=RZ+CENTR
IF(L.EQ.-2)GO TO 4
IF(L.EQ.18)GO TO 4
IF(L.EQ.38)GO TO 4
IF(L.NE.58)GO TO 32
4 RF=RE+1
RG=RE+3
CALL LINES(RJB-1.0,RG,3)
CALL LINES(RJB+1.0,RF,2)
CALL LINES(RJB+19.0,RG,3)
CALL LINES(RJB+21.0,RF,2)
32 XA=2
XB=0
IF(L.EQ.14)GO TO 6
IF(L.NE.42)GO TO 5
6 XA=20
5 IF(L.EQ.-2)GO TO 8
IF(L.EQ.26)GO TO 8
IF(L.NE.54)GO TO 7
8 XB=20
7 CALL LINES(RJB-RA-XA,RE,3)
CALL LINES(RJB+RB+XA,RE,2)
CALL LINES(RJB+RB+XB,RE+2.0,3)
30 CALL LINES(RJB-RA-XB,RE+2.0,2)
DO 31 L=-2,32,4
RZ=L
RE=RZ+RJB
CALL LINES(RE,CENTR-RC,3)
CALL LINES(RE,CENTR+RD,2)
CALL LINES(RE+2.0,CENTR+RD,3)
31 CALL LINES(RE+2.0,CENTR-RC,2)
CALL LINES(RJB-10.,CENTR-14.,3)
CALL LINES(RJB,CENTR-14.,2)
CALL LINES(RJB,CENTR-28.,3)
CALL LINES(RJB-10.,CENTR-28.,2)
1 CALL DPYOUT(2)
CALL POG1
END
SUBROUTINE SHIFT(M,L,NN)
DIMENSION M(1)
COMMON/RC/MCLEF(400),IST(4000)
EQUIVALENCE (KK,IST(2))
IF(NN.EQ.'M')GO TO 5
TYPE 7
GO TO 6
5 TYPE 1
6 KK=2
ACCEPT 2,H,V,SH,SV
IF(SH.EQ.0)SH=1
IF(SV.EQ.0)SV=1
1 FORMAT(' MOVE HORIZ, VERT., SIZE H, SIZE V'/)
2 FORMAT(4F)
7 FORMAT(' TYPE DEGREES -- '$)
CC IF(L.GT.0)GO TO 10
CC L=-L
CC V=999.
10 DO 3 K=1,L-1
CALL UNPACK(K,J,N,M)
CC IF(V.NE.999)GO TO 4
IF(NN.EQ.'M')GO TO 4
C ROTATION DEGREES.
X=J
Y=N
AX=ATAN2(Y,X)*57.2957768
HYP=SQRT(X**2+Y**2)
ROT=AX-H
C -H, SO ROTATION IS CLOCKWISE INSTEAD OF CNTRCLKWS.
C H=DEGREES
X=HYP*COSD(ROT)
Y=HYP*SIND(ROT)
AX=.5
IF(X)AX=-AX
C AX IS FOR ROUND-OFF
J=X+AX
AX=.5
IF(Y)AX=-AX
N=Y+AX
GO TO 3
4 J=H+J*SH
N=V+N*SV
3 CALL REPACK(K,J,N,M)
END
SUBROUTINE REPACK(K,M,N,I)
COMMON/LL/L
DIMENSION I(1)
M=M*10000
IF(M)M=10000000-M
IF(N)N=1000-N
M=M+L
I(K)=M+N
END
SUBROUTINE BUP
COMMON/RC/MCLEF(400),IST(4000)
IST(2)=IST(2)-1
CALL HYDPOG(1)
CALL ACCPOG(1)
END
SUBROUTINE POG2
COMMON /RC/MCLEF(3400),IST(1000)
CALL DPYSET(2,IST,200)
CALL DPYBRT(2)
END
SUBROUTINE POG1
CALL HYDPOG(3)
CALL SETPOG(1)
CALL DPYBRT(4)
END